;;;; Copyright 2009 Peter von Etter

;;;; This file is part of Autoproject

;;;; Autoproject is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation, either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; Autoproject is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with Autoproject.  If not, see
;;;; <http://www.gnu.org/licenses/>.

;; Asdf related stuff

(in-package :autoproject.util)

(defun zap-asdf ()
  "Zaps asdf into thinking that no systems have been defined.  This is
especially useful when deploying/moving saved cores around."
  (setf asdf::*defined-systems* (make-hash-table :test 'equal)))

(defun nuke-asdf ()
  "Zaps asdf, then clears the asdf central registry."
  (zap-asdf)
  (setf asdf:*central-registry* 
        (remove-if
         (lambda (x) 
           (typecase x
             (pathname t)
             (string t)
             (t nil))) 
         asdf:*central-registry*)))

(defun asdf-system-dependencies (system)
  "Returns a list of systems that SYSTEM depends on.  SYSTEM should be
an asdf system designator."
  (cdr (assoc 'asdf:load-op
              (asdf:component-depends-on
               'asdf:load-op (asdf:find-system system)))))

(defun asdf-system-dependency-tree (system)
  "Returns the dependency tree of SYSTEM.  SYSTEM should be an asdf
system designator."
  (cons system 
        (mapcar 'asdf-system-dependency-tree 
                (asdf-system-dependencies system))))


(defvar *asdf-systems* (make-hash-table :test 'equal))
(defvar *inform* t)

(labels ((canon (system)
           (string-downcase system))
     
         (inform (message &rest format-args)
           (when *inform*
             (format t "~&INFORM: ")
             (apply #'format t message format-args)
             (terpri)))
    
         (call-delete-hook (system)
           (typecase system
             (list (mapc #'call-delete-hook system))
             (t          
              (let ((del (gethash (canon system) *asdf-systems*)))
                (if del
                    (funcall del)
                    #+nil (error "System ~A not registered." system)))))))
             
  (defun delete-package-forcefully (package)
    "Ensures that PACKAGE is unused by any other package, then deletes
it."
    (typecase package
      (list (mapc 'delete-package-forcefully package))
      (t (if (find-package package)
             (progn
               (mapc (lambda (u)
                       (unuse-package package u))
                     (package-used-by-list package))
               (delete-package package)
               (inform "Deleting package ~A." package))
             (warn "Package ~A not found." package)))))
         
  (defun undefine-asdf-system (system)
    "Tricks asdf into thinking that SYSTEM hasn't been loaded."
    (typecase system
      (list (mapc #'undefine-asdf-system system))
      (t
       (if (gethash (canon system) asdf::*defined-systems*)
           (progn
             (remhash (canon system) asdf::*defined-systems*)
             (inform "Undefining system ~A." system))
           (warn "System ~A not defined." system)))))
  
  (defun delete-system (system &optional package)
    "Deletes the asdf system SYSTEM along with any packages related to
it specified by PACKAGE.  PACKAGE can be omitted if SYSTEM has been
registered with REGISTER-SYSTEM.  If a delete hook is present for a
registered system, it is also called.

SYSTEM should be an asdf system designator or a list of them.  PACKAGE
should be a package designator or a list of them."
    (undefine-asdf-system system)    
    
    (when package
      (delete-package-forcefully package))
    
    (call-delete-hook system)
    nil) 

  (defun register-system (system system-packages &key delete-hook)
    "Registers an asdf system and its related packages so that it can
later be deleted without hassle.  If DELETE-HOOK is given, it is
called with no arguments upon deletion.

SYSTEM is an asdf system designator, SYSTEM-PACKAGES is either a
package designator or a list of them.  DELETE-HOOK is a function that
takes no arguments."
    (unless (listp system-packages)
      (setf system-packages (list system-packages)))
    (setf (gethash (canon system) *asdf-systems*) 
          (lambda ()
            (handler-case
                (when delete-hook
                  (funcall delete-hook))
              (error () (warn "Delete hook failed for system ~A." system)))
            (mapc (lambda (p)
                    (when (find-package p)
                      (delete-package-forcefully p)))
                  system-packages)))))

(register-system :autoproject.util :autoproject.util)
